home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / postogrf.zip / EXTRLABS.PAS < prev    next >
Pascal/Delphi Source File  |  1990-05-21  |  12KB  |  293 lines
  1. { EXTRLABS.pas
  2.   used in POSTOGRF}
  3.  
  4. procedure ExtractLabels;
  5. { types & vars used specifically for Postscript files }
  6. type FontSpec = record
  7.                          TFont: FontList;     {type face - Helv. bold, etc}
  8.                          TSize: integer;      {font size in points}
  9.                          FontNum: string[10]; {font ID number; e.g., 'font3'}
  10.                       end;
  11. var Fonts       : array[0..20] of FontSpec;
  12.     TempFont   : FontSpec;
  13.     FontCounter: word;
  14.  
  15. {LIPSOGRF & general purpose var's}
  16. var counter, Xpos, Ypos, temp, error  : integer;
  17.     s,s1, s2                   : string80;
  18.     done                       : boolean;
  19.     tempstyle                  : Fontlist;
  20.  
  21.     procedure GetFontNum;    { here points to 'FONT' on entry }
  22.     begin if here > JimFileStart
  23.           then begin done := true; exit; end;
  24.           done := false;
  25.           GetaWord(s);
  26.           Val(s,temp,error);
  27.           If temp > FontTotal then FontTotal := temp;
  28.           counter := here;   { save pointer because GetaWord moves it}
  29.     end; {GetFontNum}
  30.  
  31.     procedure GetFontStr(fontnum:integer); { saves & restores here }
  32.     begin if done then exit;
  33.           counter := here; here := 1;
  34.           repeat
  35.                repeat GetaWord(s) until s = 'GENF';
  36.                GetaWord(s);
  37.                Val(s,temp,error);
  38.          until (temp = fontnum) or (here > JimFileStart);
  39.          repeat here := succ(here) until JimFile^[here] in quotes;
  40.          GetaQuote(s);
  41.          str(fontnum, s2);
  42.          Val(s[length(s)],temp,error) ;
  43.          tempstyle := fontlist(temp -1);
  44.                               { convert from CIEFLEX to Postscript font}
  45.          TempText.LIPSFont.LIPSStyle := tempstyle;
  46.          GetaWord(s); Val(s,temp,error);
  47.          if error <>0 then begin GetAWord(s); end;
  48.          TempText.prtSize := temp;
  49.          here := counter;     {restore pointer }
  50.     end; {GetFontStr}
  51.  
  52.     procedure GetLabel ;        { here points to 'FONT' on entry }
  53.     begin if done then exit;     { call this routine right after GetFontNum }
  54.           repeat GetAWord(s) until s = 'MAP';
  55.           GetAWord(s); Val(s,Xpos,error);
  56.           GetAWord(s); Val(s,Ypos,error);
  57.           ScrConv(XPos, YPos);
  58.           TempText.CurrText.Horiz := Xpos;
  59.           TempText.CurrText.Vert := Ypos;
  60.           repeat GetaWord(s) until s = 'TEXT';  { find the label's text }
  61.           GetAQuote(s);                         { get the text }
  62.           TempText.Tstr := s;
  63.           TempText.LabelBkGround := trans;
  64.     end;
  65.  
  66.     (*procedure GetLIPSStyle;       { figure out the CIEFLEX # in TempText }
  67.     var tempstyle: FontList;
  68.     begin tempstyle := SansSerif;
  69.           while LIPSStyleStr[tempstyle] <> s1
  70.                 do tempstyle := succ(tempstyle);
  71.           TempText.LIPSFont.LIPSStyle := tempstyle;
  72.     end;*)
  73.  
  74.    procedure LinkDefaultLabel;      { make label structure & link into list }
  75.    begin AddRec;                    { use this before GetFontNum, etc. }
  76.          SetLabelDefaults(cp);
  77.          SetUpLabel(cp);
  78.          TempText := cp^;           { copy into TempText}
  79.    end;
  80.  
  81.    { ----------------------------------------------------------------------
  82.      Font table format:  an array called Fonts:
  83.                     TFont       (FontList, Helvetica, etc)
  84.        1st font:    TSize       (integer, size in points)
  85.                     FontNum     ('font1', 'font2' , etc)
  86.  
  87.                     TFont
  88.        2nd font:    TSize
  89.                     FontNum
  90.                     ...
  91.      --------------------------------------------------------------------- }
  92.    procedure BuildPSFontTable;      { start with here pointing to font area}
  93.    type fontType = array[1..length('/font')] of char;
  94.         fontTypePtr = ^fontType;
  95.    var f1: fontlist;
  96.        t1, t2, nn: word;
  97.    const fontStrArray : fontType = '/font';
  98.    begin
  99.         s := '';
  100.         font0str := '';
  101.         { ------------------- scan for '/font0' --------------------- }
  102.         while (fontTypePtr(@JimFile^[here])^ <> fontStrArray)
  103.               and (here < EndFonts) do inc(here);
  104.         Getaword(s);
  105.         if s = '/font0' then begin
  106.               t1 := mark;
  107.               repeat GetAWord(s) until s = 'def';
  108.               for nn := t1 to here-1 do font0str := font0str + JimFile^[nn];
  109.               while (font0str[length(font0str)] in [LF, CR]) do
  110.                  delete(font0str,length(font0str),1);
  111.            end
  112.            else begin
  113.               here := mark;
  114.               font0str := defaultFont0str;
  115.            end;
  116.         Fonts[0].FontNum := '0';
  117.         s := font0str; delete(s,1,1);
  118.         delete(s, 1, pos('/',s) );
  119.         f1 := fontlist(0);
  120.            while (s <> POSTStyleStr[f1]) and (f1 <> MitreLogo) do
  121.                  inc(f1);
  122.            if s <> POSTStyleStr[f1] then f1 := HelvBold;
  123.                              {default to HelvBold if not recognized}
  124.         Fonts[0].Tfont := f1;
  125.         t1 := pos(' scalefont',s) ;
  126.         if t1 = 0 then t1 := pos(' sf',s);
  127.         t2 := t1;
  128.         while s[t1] in whitespace do dec(t1); dec(t1);
  129.         while not (s[t1] in whitespace) do dec(t1);
  130.         s := copy(s,t1,t2 - t1);
  131.         val(s, temp, error);
  132.         Fonts[0].Tsize := integer(round(temp*72.0/1000));
  133.  
  134.         FontCounter := 0;
  135.         repeat                        { until '%EndFonts'}
  136.            dec(here); GetaWordBack(s,here);
  137.            while (fontTypePtr(@JimFile^[here])^ <> fontStrArray)
  138.                and (here < EndFonts) do inc(here);
  139.            if here >= EndFonts then exit;
  140.            inc(FontCounter);
  141.            GetaWord(s);               { '/fontxx' }
  142.            Delete(s,1,1);             { change to 'fontxx' }
  143.            Fonts[FontCounter].FontNum := s;
  144.            Repeat GetAWord(s) until s[1] = '/';
  145.                               {should be '/Helvetica-Bold', or similar}
  146.            Delete(s,1,1);
  147.            f1 := fontlist(0);
  148.            while (s <> POSTStyleStr[f1]) and (f1 <> MitreLogo) do
  149.            {repeat}
  150.                  inc(f1);
  151.            {until (s = POSTStyleStr[f1]) or (f1 = MitreLogo);}
  152.            if s <> POSTStyleStr[f1] then f1 := HelvBold;
  153.                              {default to HelvBold if not recognized}
  154.            Fonts[FontCounter].TFont := f1;
  155.            repeat GetAWord(s) until (s = 'scalefont') or (s = 'sf');
  156.            t1 := here-1;
  157.            GetAWordBack(s, t1);
  158.            GetAWordBack(s, t1);       {get font size in 1/1000'2 inch}
  159.            Val(s,temp,error);          {convert to number}
  160.            Fonts[FontCounter].TSize := integer(round(temp*72.0/1000));
  161.            GetAWord(s);
  162.            if s = 'def' then GetAWord(s);
  163.         until here > EndFonts;
  164.    end; {BuildPSFontTable}
  165.  
  166.    { ----------------------------------------------------------------------
  167.      Labels have the following identifying structure:
  168.        fontxx sf                % xx is a number. Might use setfont instead.
  169.        x y m                    % x,y are numbers; could use moveto.
  170.        (text) s                 % text could have embedded or leading spaces,
  171.                                   could use show for s.
  172.  
  173.        If we encounter a label, we can extract the text using
  174.        ParsePSstring(destination, offset), which leaves offset pointing
  175.        just past the string's trailing parenthesis.
  176.      ----------------------------------------------------------------------- }
  177.  
  178.    procedure LookForFontxx;    {gets font style & size}
  179.    type fontType = array[1..length('font')] of char;
  180.         fontTypePtr = ^fontType;
  181.    var t1: word;
  182.    const fontStrArray : fontType = 'font';
  183.    begin
  184.         if here > EndLabels then exit;
  185.         repeat
  186.               GetAWord(s)
  187.         until (s = 'sf') or (s = 'setfont') or (here > EndLabels);
  188.         if here > EndLabels then exit;
  189.         t1 := here-1;
  190.         GetAWordBack(s, t1);
  191.         GetAWordBack(s, t1);
  192.         tempFont.FontNum := s;
  193.         t1 := 0;
  194.         {repeat}
  195.         while (s <> Fonts[t1].FontNum) and (t1 <> FontCounter) do inc(t1);
  196.         {until (s = Fonts[t1].FontNu